home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 2002 November / SGI Freeware 2002 November - Disc 2.iso / dist / fw_guile.idb / usr / freeware / share / guile / 1.5.6 / ice-9 / rdelim.scm.z / rdelim.scm
Text File  |  2002-07-08  |  7KB  |  198 lines
  1. ;;; installed-scm-file
  2.  
  3. ;;;; Copyright (C) 1997, 1999, 2000, 2001 Free Software Foundation, Inc.
  4. ;;;; 
  5. ;;;; This program is free software; you can redistribute it and/or modify
  6. ;;;; it under the terms of the GNU General Public License as published by
  7. ;;;; the Free Software Foundation; either version 2, or (at your option)
  8. ;;;; any later version.
  9. ;;;; 
  10. ;;;; This program is distributed in the hope that it will be useful,
  11. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13. ;;;; GNU General Public License for more details.
  14. ;;;; 
  15. ;;;; You should have received a copy of the GNU General Public License
  16. ;;;; along with this software; see the file COPYING.  If not, write to
  17. ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  18. ;;;; Boston, MA 02111-1307 USA
  19. ;;;;
  20. ;;;; As a special exception, the Free Software Foundation gives permission
  21. ;;;; for additional uses of the text contained in its release of GUILE.
  22. ;;;;
  23. ;;;; The exception is that, if you link the GUILE library with other files
  24. ;;;; to produce an executable, this does not by itself cause the
  25. ;;;; resulting executable to be covered by the GNU General Public License.
  26. ;;;; Your use of that executable is in no way restricted on account of
  27. ;;;; linking the GUILE library code into it.
  28. ;;;;
  29. ;;;; This exception does not however invalidate any other reasons why
  30. ;;;; the executable file might be covered by the GNU General Public License.
  31. ;;;;
  32. ;;;; This exception applies only to the code released by the
  33. ;;;; Free Software Foundation under the name GUILE.  If you copy
  34. ;;;; code from other Free Software Foundation releases into a copy of
  35. ;;;; GUILE, as the General Public License permits, the exception does
  36. ;;;; not apply to the code that you add in this way.  To avoid misleading
  37. ;;;; anyone as to the status of such modified files, you must delete
  38. ;;;; this exception notice from them.
  39. ;;;;
  40. ;;;; If you write modifications of your own for GUILE, it is your choice
  41. ;;;; whether to permit this exception to apply to your modifications.
  42. ;;;; If you do not wish that, delete this exception notice.
  43. ;;;; 
  44.  
  45.  
  46. ;;; This is the Scheme part of the module for delimited I/O.  It's
  47. ;;; similar to (scsh rdelim) but somewhat incompatible.
  48.  
  49. (define-module (ice-9 rdelim)
  50.   :export (read-line read-line! read-delimited read-delimited!
  51.        %read-delimited! %read-line write-line)  ; C
  52.   )
  53.  
  54. (%init-rdelim-builtins)
  55.  
  56. (define (read-line! string . maybe-port)
  57.   ;; corresponds to SCM_LINE_INCREMENTORS in libguile.
  58.   (define scm-line-incrementors "\n")
  59.  
  60.   (let* ((port (if (pair? maybe-port)
  61.            (car maybe-port)
  62.            (current-input-port))))
  63.     (let* ((rv (%read-delimited! scm-line-incrementors
  64.                  string
  65.                  #t
  66.                  port))
  67.        (terminator (car rv))
  68.        (nchars (cdr rv)))
  69.       (cond ((and (= nchars 0)
  70.           (eof-object? terminator))
  71.          terminator)
  72.         ((not terminator) #f)
  73.         (else nchars)))))
  74.  
  75. (define (read-delimited! delims buf . args)
  76.   (let* ((num-args (length args))
  77.      (port (if (> num-args 0)
  78.            (car args)
  79.            (current-input-port)))
  80.      (handle-delim (if (> num-args 1)
  81.                (cadr args)
  82.                'trim))
  83.      (start (if (> num-args 2)
  84.             (caddr args)
  85.             0))
  86.      (end (if (> num-args 3)
  87.           (cadddr args)
  88.           (string-length buf))))
  89.     (let* ((rv (%read-delimited! delims
  90.                  buf
  91.                  (not (eq? handle-delim 'peek))
  92.                  port
  93.                  start
  94.                  end))
  95.        (terminator (car rv))
  96.        (nchars (cdr rv)))
  97.       (cond ((or (not terminator)    ; buffer filled
  98.          (eof-object? terminator))
  99.          (if (zero? nchars)
  100.          (if (eq? handle-delim 'split)
  101.              (cons terminator terminator)
  102.              terminator)
  103.          (if (eq? handle-delim 'split)
  104.              (cons nchars terminator)
  105.              nchars)))
  106.         (else
  107.          (case handle-delim
  108.            ((trim peek) nchars)
  109.            ((concat) (string-set! buf (+ nchars start) terminator)
  110.              (+ nchars 1))
  111.            ((split) (cons nchars terminator))
  112.            (else (error "unexpected handle-delim value: " 
  113.                 handle-delim))))))))
  114.   
  115. (define (read-delimited delims . args)
  116.   (let* ((port (if (pair? args)
  117.            (let ((pt (car args)))
  118.              (set! args (cdr args))
  119.              pt)
  120.            (current-input-port)))
  121.      (handle-delim (if (pair? args)
  122.                (car args)
  123.                'trim)))
  124.     (let loop ((substrings '())
  125.            (total-chars 0)
  126.            (buf-size 100))        ; doubled each time through.
  127.       (let* ((buf (make-string buf-size))
  128.          (rv (%read-delimited! delims
  129.                    buf
  130.                    (not (eq? handle-delim 'peek))
  131.                    port))
  132.          (terminator (car rv))
  133.          (nchars (cdr rv))
  134.          (join-substrings
  135.           (lambda ()
  136.         (apply string-append
  137.                (reverse
  138.             (cons (if (and (eq? handle-delim 'concat)
  139.                        (not (eof-object? terminator)))
  140.                   (string terminator)
  141.                   "")
  142.                   (cons (substring buf 0 nchars)
  143.                     substrings))))))
  144.          (new-total (+ total-chars nchars)))
  145.     (cond ((not terminator)
  146.            ;; buffer filled.
  147.            (loop (cons (substring buf 0 nchars) substrings)
  148.              new-total
  149.              (* buf-size 2)))
  150.           ((eof-object? terminator)
  151.            (if (zero? new-total)
  152.            (if (eq? handle-delim 'split)
  153.                (cons terminator terminator)
  154.                terminator)
  155.            (if (eq? handle-delim 'split)
  156.                (cons (join-substrings) terminator)
  157.                (join-substrings))))
  158.           (else
  159.            (case handle-delim
  160.            ((trim peek concat) (join-substrings))
  161.            ((split) (cons (join-substrings) terminator))
  162.  
  163.  
  164.            (else (error "unexpected handle-delim value: "
  165.                 handle-delim)))))))))
  166.  
  167. ;;; read-line [PORT [HANDLE-DELIM]] reads a newline-terminated string
  168. ;;; from PORT.  The return value depends on the value of HANDLE-DELIM,
  169. ;;; which may be one of the symbols `trim', `concat', `peek' and
  170. ;;; `split'.  If it is `trim' (the default), the trailing newline is
  171. ;;; removed and the string is returned.  If `concat', the string is
  172. ;;; returned with the trailing newline intact.  If `peek', the newline
  173. ;;; is left in the input port buffer and the string is returned.  If
  174. ;;; `split', the newline is split from the string and read-line
  175. ;;; returns a pair consisting of the truncated string and the newline.
  176.  
  177. (define (read-line . args)
  178.   (let* ((port        (if (null? args)
  179.                 (current-input-port)
  180.                 (car args)))
  181.      (handle-delim    (if (> (length args) 1)
  182.                 (cadr args)
  183.                 'trim))
  184.      (line/delim    (%read-line port))
  185.      (line        (car line/delim))
  186.      (delim        (cdr line/delim)))
  187.     (case handle-delim
  188.       ((trim) line)
  189.       ((split) line/delim)
  190.       ((concat) (if (and (string? line) (char? delim))
  191.             (string-append line (string delim))
  192.             line))
  193.       ((peek) (if (char? delim)
  194.           (unread-char delim port))
  195.           line)
  196.       (else
  197.        (error "unexpected handle-delim value: " handle-delim)))))
  198.